home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / pcl-rev4.lha / ti-patches.lisp < prev    next >
Text File  |  1990-01-25  |  4KB  |  105 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. ;;;
  31. ;;; This little bit of magic keeps the dumper from dumping the lexical
  32. ;;; definition of call-next-method when it dumps method functions that
  33. ;;; come from defmethod forms.
  34. ;;; 
  35. (proclaim '(notinline nil))
  36.  
  37. (eval-when (load)
  38.   (setf (get 'function 'si:type-predicate) 'functionp))
  39.  
  40. ;; fix defsetf to deal with do-standard-defsetf
  41.  
  42. #!C
  43. ; From file SETF.LISP#> KERNEL; VIRGO:
  44. #8R SYSTEM#:
  45. (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
  46.                           (SI:*LISP-MODE* :COMMON-LISP)
  47.                           (*READTABLE* COMMON-LISP-READTABLE)
  48.                           (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  49.   (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; SETF.#"
  50.  
  51.  
  52. (defmacro defsetf (access-function arg1 &optional arg2  &environment env &body body)
  53.   "Define a SETF expander for ACCESS-FUNCTION.
  54. DEFSETF has two forms:
  55.  
  56. The simple form  (DEFSETF access-function update-function [doc-string])
  57. can be used as follows: After (DEFSETF GETFROB PUTFROB),
  58. \(SETF (GETFROB A 3) FOO) ==> (PUTFROB A 3 FOO).
  59.  
  60. The complex form is like DEFMACRO:
  61.  
  62. \(DEFSETF access-function access-lambda-list newvalue-lambda-list body...)
  63.  
  64. except there are TWO lambda-lists.
  65. The first one represents the argument forms to the ACCESS-FUNCTION.
  66. Only &OPTIONAL and &REST are allowed here.
  67. The second has only one argument, representing the value to be stored.
  68. The body of the DEFSETF definition must then compute a
  69. replacement for the SETF form, just as for any other macro.
  70. When the body is executed, the args in the lambda-lists will not
  71. really contain the value-expression or parts of the form to be set;
  72. they will contain gensymmed variables which SETF may or may not
  73. eliminate by substitution."
  74.   ;; REF and VAL are arguments to the expansion function
  75.   (if (null body)
  76.       `(defdecl ,access-function setf-method ,arg1)
  77.       (multiple-value-bind (body decls doc-string)
  78.       (parse-body body env t)
  79.     (let* ((access-ll arg1)
  80.            (value-names arg2)
  81.            (expansion
  82.          (let (all-arg-names)
  83.            (dolist (x access-ll)
  84.              (cond ((symbolp x)
  85.                 (if (not (member x lambda-list-keywords :test #'eq))
  86.                 (push x all-arg-names)
  87.                 (when (eq x '&rest) (return))))  ;;9/20/88 clm
  88.                (t            ; it's a list after &optional
  89.                 (push (car x) all-arg-names))))
  90.            (setq all-arg-names (reverse all-arg-names))
  91.            `(let ((tempvars (mapcar #'(lambda (ignore) (gensym)) ',all-arg-names))
  92.               (storevar (gensym)))
  93.               (values tempvars (list . ,all-arg-names) (list storevar)
  94.                   (let ((,(car value-names) storevar)
  95.                     . ,(loop for arg in all-arg-names
  96.                          for i = 0 then (1+ i)
  97.                          collect `(,arg (nth ,i tempvars))))
  98.                  ,@decls . ,body)
  99.                   `(,',access-function . ,tempvars))))))
  100.       `(define-setf-method ,access-function ,arg1
  101.         ,@doc-string ,expansion)
  102.       ))))
  103. ))
  104.  
  105.